00100	(DEFUN DMAC () (LIST '/!/, (READ) '(GENV)))
00200	(DEFUN GENV () (READLIST (CONS '* (EXPLODE (SETQ GENV (1+ GENV))))))
00300	(SETQ GENV 0)
00400	(SSTATUS MACRO /$ 'DMAC)
00500	
00600	(IF-NEEDED I-F-ON (IMPERATIVE-FOR (ON !>X !>Y))
00700	   (TO-MAKE (ON !,X !,Y)
00800	      (NEEDS (AND (CLEARTOP !,X) (SPACE-FOR !,X !,Y))
00900	         (PUTON X Y)))
01000	   (ADIEU 'OK))
01100	
01200	(IF-NEEDED M-O-CLEARTOP
01300	   (MEANING-OF (CLEARTOP !'X) (NOT (EXISTS ((!,Z(GENV))) (ON !,Y !,X))))
01400	   (NOTE))
01500	
01600	(IF-NEEDED S-F-NOT-ON
01700	   (SUFFICES-FOR (NOT (ON !'X !'Y))
01800	      (EXISTS ((!,Z(GENV))) (WHERE (ON !,X !,Z) (NOT (= !,Z !,Y)))))
01900	   (NOTE))
02000	
02100	(IF-NEEDED M-H-SPACE-FOR-1
02200	   (MAY-HURT (SPACE-FOR !'X !'Y)
02300	       (EXISTS ((!,Z(GENV))) (WHERE (ON !,Z !,Y) (NOT (PROTECTED (ON !,Z !,Y))))) )
02400	   (NOTE))
02500	
02600	(IF-NEEDED M-H-SPACE-FOR-2
02700	   (MAY-HURT (SPACE-FOR !'X !'Y)
02800	       (EXISTS ((!,Z(GENV))) (BADLY-PLACED !,Z !,Y)) )
02900	   (NOTE))
03000	
03100	(IF-NEEDED S-F-NOT-BADLY-PLACED
03200	   (SUFFICES-FOR (NOT (BADLY-PLACED !'X !'Y)) (PACKED !,X !,Y))
03300	   (NOTE))
03400	
03500	(IF-NEEDED I-F-PACKED (IMPERATIVE-FOR (PACKED !>X !>Y))
03600	   (TO-MAKE (PACKED !,X !,Y)
03700	      (NEEDS (AND (ON !,X !,Y) (CLEARTOP !,X))
03800	         (PACK X Y)))
03900	   (ADIEU 'OK))
04000	
04100	(IF-NEEDED P-ON (POSSIBLE (ON !>X !<SURF))
04200	   (CSETQ SURF 'TABLE) (AU-REVOIR (INSTANCE))
04300	   (TRUE1 '(FLATTOPED !>SURF)))
04400	
04500	(SSTATUS MACRO /$ NIL)
04600	
04700	(IF-NEEDED T-O-S (SPACE-FOR !>X !>Y)
04800	   (COND ((FINDSPACE X Y) (ADIEU T))))
04900	
05000	(IF-NEEDED T-O-BP (BADLY-PLACED !?X !?Y)
05100	   (COND ((PRESENT '(OCCUPIED CENTER !;X !;Y)) (NOTE))))(DEFUN FINDSPACE (OBJ SURF)
05200	   (COND ((EQ SURF 'TABLE) (GENSYM))
05300	         ((PRESENT !"(OCCUPIED CENTER !> @SURF)) NIL)
05400	         ((PRESENT !"(OCCUPIED RIGHT !> @SURF))
05500	          (COND ((PRESENT !"(OCCUPIED LEFT !> @SURF)) NIL) (T 'LEFT)))
05600	         ((PRESENT !"(OCCUPIED LEFT !> @SURF)) 'RIGHT)
05700	         (T 'CENTER)))
05800	
05900	(DEFUN BESTPACK (OBJ SURF) 'RIGHT)
06000	
06100	(DEFUN MOVE (OBJ SURF1 SURF2 PLACE)
06200	   (COND ((PRESENT !"(OCCUPIED !>P @OBJ @SURF1))
06300	          (KILL !"(OCCUPIED ,P @OBJ @SURF1))))
06400	   (INSERT !"(OCCUPIED @PLACE @OBJ @SURF2))
06500	   (PRINT !"(MOVING @OBJ FROM @SURF1 TO @SURF2 @PLACE)))
06600	
06700	(DEFUN PUSH (OBJ PLACE SURF)
06800	   (COND ((PRESENT !"(OCCUPIED !>P @OBJ @SURF))
06900	          (KILL !"(OCCUPIED ,P @OBJ @SURF))))
07000	   (INSERT !"(OCCUPIED @PLACE @OBJ @SURF))
07100	   (PRINT !"(PUSHING @OBJ TO @PLACE ON @SURF)))
07200	
07300	(CDEFUN PUTON (OBJ SURF) "AUX"(S X (CONTEXT (PUSH-CONTEXT)))
07400	   (COND ((ATOM OBJ)) (T (BUG INAPPLICABLE-PRIMITIVE (ATOM ,OBJ))))
07500	   (COND ((ATOM SURF)) (T (BUG INAPPLICABLE-PRIMITIVE (ATOM ,SURF))))
07600	   (COND ((PRESENT !"(ON !>X ,OBJ))
07700	          (BUG UNSATISFIED-PREREQUISITE (NOT (ON ,X ,OBJ)))))
07800	   (COND ((CSETQ X (FINDSPACE OBJ SURF)))
07900	         (T (BUG UNSATISFIED-PREREQUISITE (SPACE-FOR ,OBJ ,SURF))))
08000	   (COND ((PRESENT !"(ON ,OBJ !>S)) (REMOVE !"(ON ,OBJ ,S)))
08100	         (T (CSETQ S 'SOURCE)))
08200	   (ADD !"(ON ,OBJ ,SURF))
08300	   (CHECK-PROTECTEDS)
08400	   (CSET 'CONTEXT CONTEXT (ACCESS))
08500	   (MOVE OBJ S SURF X)
08600	   (WINTEST)
08700	   'OK)
08800	
08900	(CDEFUN PACK (OBJ SURF) "AUX"(S X (CONTEXT (PUSH-CONTEXT)))
09000	   (COND ((ATOM OBJ)) (T (BUG INAPPLICABLE-PRIMITIVE (ATOM ,OBJ))))
09100	   (COND ((ATOM SURF)) (T (BUG INAPPLICABLE-PRIMITIVE (ATOM ,SURF))))
09200	   (COND ((PRESENT !"(ON !>X ,OBJ))
09300	          (BUG UNSATISFIED-PREREQUISITE (NOT (ON ,X ,OBJ)))))
09400	   (COND ((PRESENT !"(ON ,OBJ ,SURF)))
09500	         (T (BUG UNSATISFIED-PREREQUISITE (ON ,OBJ ,SURF))))
09600	   (CSETQ X (BESTPACK OBJ SURF))
09700	   (CSET 'CONTEXT CONTEXT (ACCESS))
09800	   (PUSH OBJ X SURF)
09900	   (WINTEST)
10000	   'OK)